home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hottest 6
/
Hottest 6 (1996)(PDSoft)[!].iso
/
software
/
programming
/
pascal
/
hspascal-units2.lha
/
New
/
Gadgets.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-06
|
6KB
|
261 lines
unit Gadgets;
interface
{ * This unit provides an indirect interface into GadTools, to make things
a little easier to deal with
}
uses
Exec, Base, Intuition, GadTools, Utility;
const
MENUNUM = $001F; { Mask for Code in MENUPICK message to get
the number of the menu }
MENUSHIFT = 0; { Amount to 'shr' Code }
ITEMNUM = $07E0; { Mask to get the item number }
ITEMSHIFT = 5; { Amount to shift }
SUBNUM = $F800; { Mask to get the submenu item number }
SUBSHIFT = 11; { Amount to shift }
NOSUB = $1F; { Value for "no sub-item" }
var
okGadgets : boolean; { TRUE if everything initializes well }
procedure AddTitle(title: string);
procedure AddChoice(itemname: string;cmd: char;flags: word;
mx: longint;main: boolean);
function MakeMenu(win: pWindow): boolean;
implementation
{ Remember that you can change these maximums as you need to }
const
MAX_NEWMENU = 200; { Maximum number of menu items per menu strip }
MAX_MENUSTRBUF = 4000; { Maximum 4K worth of menu choice strings }
MAX_MENUSTRIPS = 20; { Maximum number of menu strips }
type
tMenuStripItem = record
menu : pMenu; { Actual menu strip put together }
window : pWindow; { Window attached to }
visinfo : pointer; { Visual info for menu }
startp : word; { Start position of strings in MenuStrBuf }
endp : word; { End position of strings in MenuStrBuf }
end;
tNewMenuArray = array[1..MAX_NEWMENU] of tNewMenu;
tMenuStrBuf = array[1..MAX_MENUSTRBUF] of char;
tMenuStripList = array[1..MAX_MENUSTRIPS] of tMenuStripItem;
var
NewMenus : tNewMenuArray;
topNewMenu : word;
MenuStrBuf : tMenuStrBuf;
topMenuStr : word;
MenuStripList : tMenuStripList;
topMenuStrip : word;
menustarted : boolean; { Has a menu been started? }
ExitSave : pointer;
{----------------------------------------------------------}
procedure AddTitle(title: string);
{ * Adds a title for a menu }
begin
if (topNewMenu+1>=MAX_NEWMENU) or
(topMenuStr+length(title)+2>=MAX_MENUSTRBUF) then
exit;
if not menustarted then
begin
if topMenuStrip>=MAX_MENUSTRIPS then
exit;
inc(topMenuStrip);
with MenuStripList[topMenuStrip] do
begin
menu := nil;
window := nil;
startp := topMenuStr+1;
endp := startp
end;
menustarted := TRUE
end;
inc(topNewMenu);
with NewMenus[topNewMenu] do
begin
nm_Type := NM_TITLE;
title := title+#0;
move(title[1],MenuStrBuf[topMenuStr+1],length(title));
nm_Label := @MenuStrBuf[topMenuStr+1];
inc(topMenuStr,length(title));
nm_CommKey := nil;
nm_Flags := 0;
nm_MutualExclude := 0;
nm_UserData := nil
end;
end;
{----------------------------------------------------------}
procedure AddChoice(itemname: string;cmd: char;flags: word;
mx: longint;main: boolean);
{ * Adds a choice to a menu.
ITEMNAME is the text of the menu item, '_' for a bar.
CMD is the keyboard shortcut command, #0 for none
FLAGS include CHECKED, CHECKIT and MENUTOGGLE
MX is the mutual exclude mask (add all 1 shl itemnumbers together)
Use zero here if the choice is not of a CHECKIT type
MAIN is TRUE if this is a main item, FALSE if it is a sub-item }
var
command : string[2];
begin
if topMenuStr+ord(itemname<>'_')*(length(itemname)+2+2*ord(cmd>#0))
>=MAX_MENUSTRBUF then
exit;
if not menustarted or (topNewMenu+1>=MAX_NEWMENU) then
exit;
inc(topNewMenu);
with NewMenus[topNewMenu] do
begin
if main then
nm_Type := NM_ITEM
else
nm_Type := NM_SUB;
if itemname='_' then
begin
nm_Label := STRPTR(NM_BARLABEL);
nm_CommKey := nil
end
else
begin
itemname := itemname+#0;
move(itemname[1],MenuStrBuf[topMenuStr+1],length(itemname));
nm_Label := @MenuStrBuf[topMenuStr+1];
inc(topMenuStr,length(itemname));
if cmd>#0 then
begin
command := cmd+#0;
move(command[1],MenuStrBuf[topMenuStr+1],length(command));
nm_CommKey := @MenuStrBuf[topMenuStr+1];
inc(topMenuStr,length(command));
end
else
nm_CommKey := nil;
MenuStripList[topMenuStrip].endp := topMenuStr
end;
nm_Flags := flags;
nm_MutualExclude := mx;
nm_UserData := nil
end
end;
{----------------------------------------------------------}
function MakeMenu(win: pWindow): boolean;
{ * This function makes and attaches the menu to the given
window, returning TRUE for a successful operation
}
var
taglist : tTagItem;
menumade : boolean;
begin
if not menustarted or (topNewMenu=0) then
begin
MakeMenu := FALSE;
exit;
end;
menumade := FALSE;
inc(topNewMenu);
with NewMenus[topnewmenu] do
begin
nm_Type := NM_END;
nm_Label := nil;
nm_CommKey := nil;
nm_Flags := 0;
nm_MutualExclude := 0;
nm_userData := nil
end;
with taglist do
begin
ti_Tag := TAG_END;
ti_Data := 0
end;
with MenuStripList[topMenuStrip] do
begin
menu := CreateMenusA(@NewMenus[1],@taglist);
if menu<>nil then
begin
visinfo := GetVisualInfoA(win^.WScreen,@taglist);
if visinfo<>nil then
begin
if LayoutMenusA(menu,visinfo,@taglist) then
begin
if SetMenuStrip(win,menu) then
begin
menumade := TRUE;
window := win
end
else
begin
FreeMenus(menu);
FreeVisualInfo(visinfo)
end
end
else
FreeVisualInfo(visinfo)
end
end
end;
menustarted := FALSE;
topNewMenu := 0;
MakeMenu := menumade
end;
{----------------------------------------------------------}
procedure CloseTopMenu;
begin
with MenuStripList[topMenuStrip] do
begin
ClearMenuStrip(window);
FreeMenus(menu);
FreeVisualInfo(visinfo);
topMenuStr := startp-1
end;
dec(topMenuStrip)
end;
{----------------------------------------------------------}
{$F+}
procedure CloseGadgets;
begin
if menustarted then
begin
dec(topMenuStrip);
menustarted := FALSE
end;
while topMenuStrip>0 do
CloseTopMenu;
ExitProc := ExitSave; { Restore exit pointer }
if GadToolsBase<>nil then
CloseLibrary(GadToolsBase)
end;
{----------------------------------------------------------}
{ Initialization section patches exit routine to close library
upon exit and initializes the library
}
begin
okGadgets := FALSE;
GadToolsBase := nil;
topMenuStr := 0;
topNewMenu := 0;
topMenuStrip := 0;
menustarted := FALSE;
ExitSave := ExitProc;
ExitProc := @CloseGadgets; { Add CloseGadgets to exit chain }
GadToolsBase := OpenLibrary('gadtools.library',0);
if GadToolsBase<>nil then
okGadgets := TRUE
end.